home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gwuada_9.zip / 5.C < prev    next >
C/C++ Source or Header  |  1993-07-27  |  31KB  |  1,147 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. /* Todo: 
  10.  
  11.  3-12-86    ds    
  12.  Modify format of as_return node so that new node of type as_number
  13.  put in N_AST3 field to hold depth count formerly kept in N_VAL.
  14.  
  15.  30-oct-84    ds
  16.  Note that N_VAL for node produced at end of return_statement()
  17.  is different, is now integer giving depth, was tuple of length two.
  18.  
  19.  
  20. id is defined in goto_statement but never used
  21.  
  22. */
  23.  
  24. #include "attr.h"
  25. #include "hdr.h"
  26. #include "vars.h"
  27. #include "setp.h"
  28. #include "dclmapp.h"
  29. #include "miscp.h"
  30. #include "errmsgp.h"
  31. #include "dbxp.h"
  32. #include "evalp.h"
  33. #include "nodesp.h"
  34. #include "smiscp.h"
  35. #include "chapp.h"
  36.  
  37. #define label_unreachable 0
  38. #define label_reachable 1
  39.  
  40. static void new_symbol(Symbol, int, Symbol, Tuple, Symbol);
  41. static Const get_static_nval(Node);
  42. static void replace_others(Node, Node, int, int);
  43.  
  44. Symbol slice_type(Node node, int is_renaming)         /*;slice_type*/
  45. {
  46.     Node   array_node, range_node, low_node, high_node, type_node;
  47.     Node   new_range_node, arg1, arg2, var_node;
  48.     Symbol type_name, type_mark, index_name, i_type;
  49.     Tuple  tup;
  50.     int    attr_prefix, kind;
  51.  
  52.     /* We must have a subtype for the aggregate to give the bounds */
  53.     if (is_renaming) {
  54.         var_node = N_AST3(node);
  55.     } 
  56.     else
  57.         var_node = N_AST1(node);
  58.     array_node = N_AST1(var_node);
  59.     range_node = N_AST2(var_node);
  60.     kind = N_KIND(range_node);
  61.     if (kind == as_simple_name || kind == as_name)
  62.         type_name = N_UNQ(range_node);
  63.     else {
  64.         if (kind == as_subtype) {
  65.             type_node = N_AST1(range_node);
  66.             new_range_node = N_AST2(range_node);
  67.             low_node  = N_AST1(new_range_node);
  68.             high_node = N_AST2(new_range_node);
  69.         }
  70.         else if (kind == as_range) {
  71.             low_node = N_AST1(range_node);
  72.             high_node = N_AST2(range_node);
  73.         }
  74.         else if (kind == as_attribute) {
  75.             /*att_node = N_AST1(range_node); -- not needed in C */
  76.             arg1 = N_AST2(range_node);
  77.             arg2 = N_AST3(range_node);
  78.             /* subtract code for ATTR_FIRST to get T_ or O_ value */
  79.             /* recall that in C attribute kind kept in range_node*/
  80.             attr_prefix = (int)attribute_kind(range_node)-ATTR_RANGE;
  81.             /* 'T' or 'O' */
  82.             attribute_kind(range_node) = (char *)((int) attr_prefix+ATTR_FIRST);
  83.             low_node = range_node;
  84.             high_node = new_attribute_node(attr_prefix+ATTR_LAST,
  85.               copy_node(arg1), copy_node(arg2), get_type(range_node));
  86.             eval_static(low_node);
  87.             eval_static(high_node);
  88.         }
  89.         else {
  90.             errmsg("Unexpected range in slice", "", range_node );
  91.             low_node = OPT_NODE;
  92.             high_node = OPT_NODE;
  93.         }
  94.         /* We need the bounds twice, for the slice and for the aggregate
  95.          * so we build an anonymous subtype to avoid double evaluation
  96.          */
  97.         if (N_KIND(array_node) == as_simple_name
  98.           || N_KIND(array_node) == as_name)
  99.             type_mark = TYPE_OF(N_UNQ(array_node));
  100.         else
  101.             type_mark = N_TYPE(array_node);
  102.         type_mark = base_type(type_mark);        /* get base type */
  103.         index_name = named_atom("slice_index_type");
  104.         type_name = named_atom("slice_type");
  105.         i_type= (Symbol) index_type(type_mark);
  106.         tup = constraint_new(0);
  107.         tup[2] = (char *) low_node;
  108.         tup[3] = (char *) high_node;
  109.         new_symbol(index_name, na_subtype, i_type, tup, ALIAS(i_type));
  110.         SCOPE_OF(index_name) = scope_name;
  111.  
  112.         tup = constraint_new(4);
  113.         tup[1] = (char *) tup_new1((char *) index_name);
  114.         tup[2] = (char *) component_type(type_mark);
  115.  
  116.         new_symbol(type_name, na_subtype, type_mark, tup, ALIAS(type_mark));
  117.         SCOPE_OF(type_name) = scope_name;
  118.         tup = tup_new(2);
  119.         tup[1] = (char *) new_subtype_decl_node(index_name);
  120.         tup[2] = (char *) new_subtype_decl_node(type_name);
  121.         make_insert_node(node, tup, copy_node(node));
  122.         N_AST1(var_node)  = array_node;
  123.         N_AST2(var_node)  = new_name_node(index_name);
  124.         copy_span(range_node, N_AST2(var_node));
  125.     }
  126.     return type_name;
  127. }
  128.  
  129. static void new_symbol(Symbol new_name, int new_nature, Symbol new_type,
  130.   Tuple new_signature, Symbol new_alias)                        /*;new_symbol*/
  131. {
  132.     NATURE(new_name)    = new_nature;
  133.     TYPE_OF(new_name)    = new_type;
  134.     SIGNATURE(new_name) = new_signature;
  135.     ALIAS(new_name)    = new_alias;
  136.     dcl_put(DECLARED(scope_name), str_newat(), new_name);
  137. }
  138.  
  139. Symbol get_type(Node node)                                        /*;get_type*/
  140. {
  141.     /*
  142.      * GET_TYPE is procedure get_type() in C:
  143.      *     macro GET_TYPE(node);
  144.      *  (if N_KIND(node) in [as_simple_name, as_subtype_indic]
  145.      *                        then TYPE_OF(N_UNQ(node))
  146.      *                        }
  147.      *                        else N_TYPE(node) end )                   endm;
  148.      */
  149.  
  150.     int    nk;
  151.     Symbol    sym;
  152.  
  153.     nk = N_KIND(node);
  154.     if (nk == as_simple_name || nk == as_subtype_indic) {
  155.         sym = N_UNQ(node);
  156.         if (sym == (Symbol)0) {
  157. #ifdef DEBUG
  158.             zpnod(node);
  159. #endif
  160.             chaos("get_type: N_UNQ not defined for node");
  161.         }
  162.         else
  163.             sym =  TYPE_OF(sym);
  164.     }
  165.     else
  166.         sym = N_TYPE(node);
  167.  
  168.     return sym;
  169. }
  170.  
  171. void assign_statement(Node node)  /*;assign_statement*/ 
  172. {
  173.     Node var_node, exp_node;
  174.     Symbol t, t1, t2, ok_sym;
  175.     Set    t_l, t_left, t_right, ok_types, ook_types;
  176.     Forset    tiv, tforl, tforr, fs1;
  177.  
  178.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  assign_statement");
  179.  
  180.     var_node = N_AST1(node);
  181.     exp_node = N_AST2(node);
  182.  
  183.     noop_error = FALSE;        /* To clear previous type errors */
  184.  
  185.     adasem(var_node);
  186.     find_old(var_node);            /* left-hand side is a name.*/
  187.     adasem(exp_node);
  188.  
  189.     resolve1(var_node);
  190.     t_l = N_PTYPES(var_node);
  191.     t_left = set_new(0);
  192.     FORSET(t = (Symbol), t_l, tiv);
  193.         if (! is_limited_type(t)) t_left = set_with(t_left, (char *) t);
  194.     ENDFORSET(tiv);
  195.     resolve1(exp_node);
  196.     t_right = N_PTYPES(exp_node);
  197.  
  198.     if (noop_error) {    /* previous error. */
  199.         noop_error = FALSE;
  200.         return;
  201.     }
  202.  
  203.     ok_types = set_new(0);
  204.     FORSET(t1 = (Symbol), t_left, tforl);
  205.         FORSET(t2 = (Symbol), t_right, tforr);
  206.             if (compatible_types(t1, t2) )
  207.                 ok_types = set_with(ok_types, (char *) t1);
  208.         ENDFORSET(tforr);
  209.     ENDFORSET(tforl);
  210.     /* For the assignment to be unambiguous, the left-hand and right_hand
  211.      * sides must have a single compatible interpretation.
  212.      */
  213.     if (set_size(ok_types) == 0) {
  214.         if (set_size(t_l) == 1 && set_size(t_left) == 0) {
  215.             errmsg("assignment not available on a limited type", "7.4.2",
  216.               var_node);
  217.             set_free(ok_types);
  218.             return;
  219.         }
  220.         else {
  221.             errmsg("incompatible types for assignment", "5.2", node);
  222.             set_free(ok_types);
  223.             return;
  224.         }
  225.     }
  226.     else if (set_size(ok_types) > 1) {    /* ambiguous left-hand side */
  227.         remove_conversions(var_node);        /* last chance. */
  228.         ook_types = ok_types;
  229.         ok_types = set_new(0);
  230.         FORSET(ok_sym=(Symbol), N_PTYPES(var_node), fs1);
  231.             if (set_mem((char *) ok_sym, ook_types))
  232.                 ok_types = set_with(ok_types, (char *)ok_sym);
  233.         ENDFORSET(fs1);
  234.         set_free(ook_types);
  235.         if (set_size(ok_types) != 1) {
  236.             errmsg("ambiguous types for assigment", "5.2", var_node);
  237.             set_free(ok_types);
  238.             return;
  239.         }
  240.     }
  241.     t1 = (Symbol) set_arb(ok_types);  /* Now unique. */
  242.     set_free(ok_types);
  243.     out_context = TRUE;
  244.     resolve2(var_node, t1);
  245.     out_context = FALSE;
  246.     /*if (N_KIND(var_node) == as_slice && (N_KIND(exp_node) == as_aggregate
  247.         ||N_KIND(exp_node) == as_string_literal)){*/
  248.  
  249.     /* we don't have to care about the type of the right hand side cf Setl */
  250.     if (N_KIND(var_node) == as_slice) {
  251.         /* context is constrained, even though type of lhs is base type
  252.          * This means that an OTHERS association is allowed.
  253.          */
  254.         t1 = slice_type(node,0);
  255.         resolve2 (exp_node, t1);
  256.         return;
  257.     }
  258.  
  259.     if(NATURE(t1) == na_array && N_UNQ(var_node) != (Symbol)0 &&
  260.       (NATURE(N_UNQ(var_node))==na_inout || NATURE(N_UNQ(var_node))==na_out))
  261.         replace_others(exp_node, var_node, tup_size(index_types(t1)), 1);
  262.  
  263.     resolve2(exp_node, t1);
  264.  
  265.     if (! is_variable(var_node)){
  266.         errmsg("left-hand side in assignment is not a variable", "5.2",
  267.           var_node);
  268.         return;
  269.     }
  270.  
  271.     if (is_array(t1) ) {
  272.         /* array assignments are length_checked in the interpreter, and don't
  273.          * carry a qualification.
  274.          */
  275.         ;
  276.     }
  277.     else if (!in_qualifiers(N_KIND(exp_node))) {
  278.         /* a constraint check on the right hand side may be needed.*/
  279.         N_TYPE(exp_node) = base_type(t1);
  280.         apply_constraint(exp_node, t1);
  281.     }
  282.     eval_static(var_node);
  283.     eval_static(exp_node);
  284.  
  285.     noop_error = FALSE;        /* clear error flag */